﻿\ http://web.archive.org/web/20080617192945/http://www.albany.net/~hello/sokoban.htm

\ for Jacques Barzun on his 88th birthday 30NOV95
\ revised 28MAY96

: RULES   0 21 AT-XY
   ." Sokoban is a game of pushing.  You are Soko "
   ." (@).  Your aim is to push" CR
   ." rocks ($) to their goals (.).  You can push "
   ." only one rock at a time," CR
   ." and you can neither step nor push through a "
   ." wall (#).  Best wishes!" ;

\ miscellaneous tools
: CHAR-  ( a - a')  1 CHARS - ;
: CHAR/  ( n - n')  1 CHARS / ;
: DOWNOVER  ( n1 n2 n3 - n1 n2 n1 n3)  >R OVER R> ;
: OFF  ( a)  0 SWAP ! ;
: INCR  ( a)  1 SWAP +! ;
: DECR  ( a)  -1 SWAP +! ;
: @!  ( n1 a - n2)  DUP @ >R  !  R> ;
: FOR  ( a u - a' a)  OVER + SWAP ;
: BETWEEN  ( n1 n2 n3 - f)  1+ WITHIN ;
: c>C  ( c - c')  DUP [CHAR] a [CHAR] z BETWEEN
   BL AND XOR ;
: BIGKEY  ( - c)  KEY c>C ;
: BEEP   7 EMIT ;  \ implementation dependent?
: CSEARCH  ( c a u - u'|0)  0 
   ?DO 2DUP
      C@ = IF 2DROP I 1+ UNLOOP EXIT THEN
   CHAR+  LOOP
   2DROP FALSE ;
\ get-number from Woehr, Forth: The New Model, p. 153
: GET-NUMBER  ( - d f)  0.
   PAD 84 BLANK  PAD 84 ACCEPT  PAD SWAP -TRAILING
   >NUMBER NIP  0= ;
: #INPUT  ( - #)  GET-NUMBER DROP  D>S ;

\ game pieces and variables
CHAR @ CONSTANT SOKO  \ our hero
    BL CONSTANT VACANT
CHAR $ CONSTANT ROCK
CHAR * CONSTANT GEM
CHAR . CONSTANT GOAL
CHAR # CONSTANT WALL
VARIABLE where's-soko  \ Soko's position in the maze
VARIABLE rocks
VARIABLE gems
VARIABLE steps
VARIABLE pushes
VARIABLE no-nos

\ maze ground
20 CONSTANT #ROWS
20 CONSTANT #COLS
#ROWS #COLS * CONSTANT MAP
MAP CHARS CONSTANT TERRITORY
#COLS CHARS CONSTANT WIDTH
CREATE MAZE  TERRITORY ALLOT
: CLEAR-MAZE   MAZE MAP BLANK ;
: MAZE-XY  ( a - col row)
   MAZE -  CHAR/  #COLS /MOD ;
: AT-MAZE  ( a)
   MAZE-XY AT-XY ;

\ sokoban.dat contains 85 mazes,
\ each delimited by a line that begins with (
CHAR ( CONSTANT DELIMITER
0 VALUE MAZEFILE
VARIABLE maze#
: OPEN-MAZES   S" sokoban.dat" R/O OPEN-FILE
   ABORT" OPEN-MAZES problem" TO MAZEFILE ;
: CLOSE-MAZES   MAZEFILE CLOSE-FILE
   ABORT" CLOSE-MAZES problem" ;
: >BOF  ( fileid)
   0.  ROT REPOSITION-FILE ABORT" >BOF problem" ;
: MAZE-LINE  ( - a u)
   PAD  DUP [ #COLS 2 + ] LITERAL
   MAZEFILE READ-LINE ABORT" MAZE-LINE problem"
   DROP ;
: CHOOSE  ( - n)
   0
   BEGIN DROP  PAGE ." Maze Number (1 to 85):"
         #INPUT  DUP 1 85 BETWEEN UNTIL  DUP maze# ! ;
\ use  = -1 AND +  if true-flag <> -1
: SEEK  ( n)
   MAZEFILE >BOF
   BEGIN
   DUP WHILE
     MAZE-LINE DROP  C@ DELIMITER = +
   REPEAT
   DROP ;
: GET
   CLEAR-MAZE  MAZE
   BEGIN MAZE-LINE  OVER C@ DELIMITER <> 
   WHILE DOWNOVER CMOVE  WIDTH +  REPEAT  2DROP DROP ;
: .ROW  ( a)  #COLS -TRAILING TYPE  CR ;
: SHOW
   PAGE  MAZE TERRITORY FOR  DO I .ROW  WIDTH +LOOP ;
\ store VACANT in Soko's spot,
\ and store Soko's spot in where's-soko
: !SOKO  ( a)
   VACANT OVER C!  where's-soko ! ;
: TALLY
   rocks OFF  gems OFF  MAZE MAP 0
   DO COUNT DUP ROCK = IF DROP  rocks INCR  ELSE
            DUP GEM  = IF DROP  gems INCR   ELSE
                SOKO = IF DUP CHAR- !SOKO
                       THEN THEN THEN
   LOOP  DROP ; 
:  AMAZE
    CHOOSE SEEK GET SHOW TALLY ;

: SCOREBOARD
   steps OFF  pushes OFF  no-nos OFF
   40  0 AT-XY  ."   MAZE: "  maze# ?
   40  2 AT-XY  ."   GEMS:"
   40  4 AT-XY  ."  ROCKS:"
   40  6 AT-XY  ."  STEPS:"
   40  8 AT-XY  ." PUSHES:"
   40 10 AT-XY  ." NO-NOS:"
   40 13 AT-XY  ."      E/I/8"
   40 14 AT-XY  ." S/J/4 < > F/L/6   Q quits"
   40 15 AT-XY  ."      C/</2" ;

: .SCORE
   48  2 AT-XY gems ?
   48  4 AT-XY rocks ?
   48  6 AT-XY steps ?
   48  8 AT-XY pushes ?
   48 10 AT-XY no-nos ? ;
: .SOKO
   where's-soko @ MAZE-XY
   2DUP AT-XY SOKO EMIT  AT-XY ;
: STATUS   .SCORE .SOKO ;

\ In the following stack comments,
\ a1 is where Soko wants to go to
\ a2 is where a rock or gem in a1 would be pushed to

\ moves  
\ when moving Soko, redisplay old spot,
\ and store Soko's new spot
: MOVE-SOKO  ( a1)
   where's-soko @!  DUP AT-MAZE C@ EMIT  ;
\ move without pushing
: STEP  ( a1 a2)
   DROP  MOVE-SOKO  steps INCR ;
\ when pushing a rock or gem,
\ put rock/gem in a2; restore vacant/goal to a1,
\ and move soko to a1
: PUT  ( rock|gem a2)
   2DUP C!  AT-MAZE EMIT ;
: PUSH  ( a2 rock|gem)
   SWAP PUT  pushes INCR ;
: UNDER-SOKO  ( a1 vacant|goal)
   OVER C!  MOVE-SOKO ;
: PUSH-ROCK  ( a1 a2)
   ROCK PUSH  VACANT UNDER-SOKO ;
: PUSH-GEM  ( a1 a2)
   GEM PUSH  GOAL UNDER-SOKO ;
\ a rock pushed to a goal becomes a gem
: +GEM  ( a1 a2)
   GEM PUSH  VACANT UNDER-SOKO
   gems INCR  rocks DECR ;
\ a gem pushed to a spot that's vacant becomes a rock
: -GEM  ( a1 a2)
   ROCK PUSH  GOAL UNDER-SOKO
   gems DECR  rocks INCR ;
\ illegal move
: NO-NO  ( a1 a2)
   2DROP  BEEP  no-nos INCR ;

\ moves are e/w/s/n
     1 CHARS CONSTANT EAST
    -1 CHARS CONSTANT WEST
       WIDTH CONSTANT SOUTH
WIDTH NEGATE CONSTANT NORTH
\ compute next spot and the spot beyond
\ don't care if a2 is outside of maze,
\ since a1 must then be a wall
: WARD  ( e|w|s|n - a1 a2)
   DUP where's-soko @ +  DUP ROT + ;
\ what Soko might see up ahead
CREATE LOOKS  5 C,
   VACANT C,  GOAL C,  ROCK C,  GEM C,  WALL C,
\ 0 max keeps out-of-maze a2 within the jump table
: SIGHT  ( a - n|0)
   C@  LOOKS COUNT  CSEARCH 1-  0 MAX ;
: PROSPECT  ( a1 a2  - n1 n2)
   >R SIGHT  R> SIGHT ;

\ 2jump adapted from Dwight Elvey's 2array,
\ comp.lang.forth, 25JUL95
: CELL*  ( n1 n2...nn n - n1cells n2cells...nncells)
   DUP 0 ?DO DUP ROLL CELLS  SWAP  LOOP  DROP ;
: INDEX  ( u a n - a')
   0 DO DUP ,  OVER +  LOOP  NIP ;
: JUMP  ( n a - a')
   SWAP CELLS + ;
: 2JUMP
   CREATE  ( #x's #y's - u)  
    TUCK       \ need index entry for each y
    2 CELL*    \ #x's and #y's * CELL
    HERE +     \ 1st index entry
    ROT INDEX  \ make index
    HERE -     \ space to allot
   DOES>  ( x y - a)  JUMP @  JUMP ;
\ is from Brodie
\ Thinking FORTH, reprint edition, p. 223
: IS   ' , ;
: ARE  ( n)
   0 DO IS LOOP ;

5 5 2JUMP OUTCOME  DROP
\ n1 vacant goal rock      gem      wall  \  n2
5 ARE STEP  STEP PUSH-ROCK -GEM     NO-NO \ vacant
5 ARE STEP  STEP +GEM      PUSH-GEM NO-NO \ goal       
5 ARE STEP  STEP NO-NO     NO-NO    NO-NO \ rock 
5 ARE STEP  STEP NO-NO     NO-NO    NO-NO \ gem
5 ARE STEP  STEP NO-NO     NO-NO    NO-NO \ wall

: HO!  ( a1 a2)
   2DUP PROSPECT  OUTCOME @ EXECUTE  STATUS ;

\ keys for lefties, righties, and numerists
\ ignore invalid keys
: UP  ( c - u|0)
   S" EI8"  CSEARCH ;
: LEFT  ( c - u|0)
   S" SJ4"  CSEARCH ;
: RIGHT  ( c - u|0)
   S" FL6"  CSEARCH ;
: DOWN  ( c - u|0)
   S" C,<2" CSEARCH ;
: Q=  ( c - f)  [CHAR] Q = ;

\ sokoban
: PLAY
   AMAZE RULES SCOREBOARD STATUS
   BEGIN BIGKEY  
      DUP UP    IF NORTH WARD HO! ELSE
      DUP DOWN  IF SOUTH WARD HO! ELSE
      DUP RIGHT IF EAST  WARD HO! ELSE
      DUP LEFT  IF WEST  WARD HO!
                   THEN THEN THEN THEN  
   Q=  rocks @ 0=  OR UNTIL ;
: DONE  ( - f)  40 17 AT-XY
   ." PLAY AGAIN (y/n)?"  BIGKEY [CHAR] Y <> ;
: SOKOBAN
   OPEN-MAZES  BEGIN PLAY  DONE UNTIL  CLOSE-MAZES ;

SOKOBAN
